home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue30 / bdeorx / BDEDORX.ZIP / DBFTbl / DBFTable.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-12-18  |  6.3 KB  |  217 lines
  1. unit DBFTable;
  2.  
  3. (*
  4.  
  5. ***************************************************************
  6. *                                                             *
  7. *  DBFTable compoment                                         *
  8. *                                                             *
  9. *  (c) 1997 Reinhard Kalinke                                  *
  10. *                                                             *
  11. *  r_kalinke@compuserve.com                                   *
  12. *                                                             *
  13. ***************************************************************
  14.  
  15. This TTable descendant adds means to handle missing MDX and DBT
  16. files with dBase tables. It also implements autosaving changes
  17. to disk. However, this will not have the desired effect as all
  18. BDE versions (tested up to 4.01) do not implement that feature
  19. correctly.
  20.  
  21. *)
  22.  
  23. interface
  24.  
  25. uses
  26.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  27.   Forms, Dialogs, DB, DBTables, BDEDoRxS, DBITypes;
  28.  
  29. type
  30.   TDBFAtDBTMissing = (atdOpenWithout,atdOpenError,atdRemoveFields);
  31.   TDBFAtMDXMissing = (atmOpenReadOnly,atmOpenError,atmDetachMDX);
  32.   TDBFOpenFailType = (ofNone,ofMDXMissing,ofDBTMissing);
  33.   TDBFOpenFailure = procedure(Sender: TObject;
  34.                          FailType: TDBFOpenFailType) of object;
  35.   TDBFFailRec = record
  36.     FailType: TDBFOpenFailType;
  37.     DBTAction: TDBFAtDBTMissing;
  38.     MDXAction: TDBFAtMDXMissing;
  39.   end;
  40.  
  41.   TDBFTable = class(TTable)
  42.   private
  43.     FFailRec: TDBFFailRec;
  44.     FOnOpenFailure: TDBFOpenFailure;
  45.     FInputDesc: cbInputDesc;
  46.     FAutoSaveChanges: boolean;
  47.     procedure SetAtDBTMissing(Value: TDBFAtDBTMissing);
  48.     procedure SetAtMDXMissing(Value: TDBFAtMDXMissing);
  49.     procedure SetAutoSaveChanges(Value: boolean);
  50.   protected
  51.     procedure DoBeforeOpen; override;
  52.     procedure DoAfterOpen; override;
  53.     procedure DoAfterPost; override;
  54.     procedure DoAfterDelete; override;
  55.     function CreateHandle: hDBICur; override;
  56.   public
  57.     constructor Create(AOwner: TComponent); override;
  58.   published
  59.     property AtDBTMissing: TDBFAtDBTMissing
  60.       read FFailRec.DBTAction write SetAtDBTMissing default atdOpenWithout;
  61.     property AtMDXMissing: TDBFAtMDXMissing
  62.       read FFailRec.MDXAction write SetAtMDXMissing default atmDetachMDX;
  63.     property AutoSaveChanges: boolean
  64.       read FAutoSaveChanges write SetAutoSaveChanges default True;
  65.     property OnOpenFailure: TDBFOpenFailure
  66.       read FOnOpenFailure write FOnOpenFailure;
  67.   end;
  68.  
  69. procedure Register;
  70.  
  71. implementation
  72.  
  73. uses DBIProcs, DBIErrs;
  74.  
  75. {$S-} {no stack checking in a callback, at least with 16bit} (**)
  76. function InputRequestCallback(ecbType:CBType;
  77.            Failure:Longint; var CBInfo:pointer):CBRType;
  78.            {$IFDEF WIN32}stdcall;{$ELSE}export;{$ENDIF}
  79. var InputDesc: pcbInputDesc;
  80.     FailType: TDBFOpenFailType;
  81.     FailRec: TDBFFailRec;
  82. begin
  83.   Result := cbrUSEDEF;
  84.   if (ecbType = CBType(cbINPUTREQ)) then
  85.   begin
  86.     InputDesc := pcbInputDesc(@CBInfo);
  87.     FailRec := TDBFFailRec(pointer(Failure)^);
  88.     if InputDesc^.eCbInputId = cbiMDXMISSING then
  89.     begin
  90.       FailType := ofMDXMissing;
  91.       InputDesc^.iSelection := succ(ord(FailRec.MDXAction));
  92.     end;
  93.     if InputDesc^.eCbInputId = cbiDBTMISSING then
  94.     begin
  95.       FailType := ofDBTMissing;
  96.       InputDesc^.iSelection := succ(ord(FailRec.DBTAction));
  97.     end;
  98.     if (FailType <> ofNone) then
  99.     begin
  100.       TDBFFailRec(pointer(Failure)^).FailType := FailType;
  101.       InputDesc^.bSave := False;
  102.       Result := cbrCHKINPUT;
  103.     end;
  104.   end;
  105. end;
  106. {S+} {stack checking on again} (**)
  107.  
  108. constructor TDBFTable.Create(AOwner: TComponent);
  109. begin
  110.   inherited Create(AOwner);
  111.   FFailRec.DBTAction := atdOpenWithout;
  112.   FFailRec.MDXAction := atmDetachMDX;
  113.   FAutoSaveChanges := True;
  114. end;
  115.  
  116. procedure TDBFTable.DoBeforeOpen;
  117. var r: DBIResult;
  118. begin
  119.   inherited DoBeforeOpen;
  120.   DBIRegisterCallback( nil,
  121.                        CBType(cbINPUTREQ),
  122.                        longint(@FFailRec),
  123.                        sizeof(cbINPUTDesc),
  124.                        @FInputDesc,
  125.                        {$IFDEF WIN32}
  126.                        @InputRequestCallBack);
  127.                        {$ELSE}
  128.                        InputRequestCallBack);
  129.                        {$ENDIF}
  130. end;
  131.  
  132. function TDBFTable.CreateHandle: hDBICur;
  133. var BDEError: DBIResult;
  134.     i: integer;
  135. begin
  136.   try try
  137.     Result := inherited CreateHandle;
  138.   except
  139.     on E:EDBEngineError do
  140.     begin
  141.       for i:=0 to pred(E.ErrorCount) do
  142.       begin
  143.         BDEError := E.Errors[i].ErrorCode;
  144.         if (BDEError = DBIERR_BLOBFILEMISSING) then
  145.           FFailRec.FailType := ofDBTMissing;
  146.         if (BDEError = DBIERR_NOSUCHINDEX) then
  147.           FFailRec.FailType := ofMDXMissing;
  148.       end;
  149.       if (FFailRec.FailType <> ofNone) then
  150.         Sysutils.Abort
  151.       else raise;
  152.     end;{}
  153.   end;
  154.   finally
  155.     DBIRegisterCallback(nil, CBType(cbINPUTREQ),
  156.                         0, 0, nil, nil);
  157.     DBIUseIdleTime;
  158.     if ((FFailRec.FailType = ofDBTMissing)
  159.      and (FFailRec.DBTAction = atdOpenError))
  160.     or ((FFailRec.FailType = ofMDXMissing)
  161.      and (FFailRec.MDXAction = atmOpenError))
  162.     and Assigned(FOnOpenFailure) then
  163.       FOnOpenFailure(Self, FFailRec.FailType);
  164.     FFailRec.FailType := ofNone;
  165.   end;
  166. end;
  167.  
  168. procedure TDBFTable.DoAfterOpen;
  169. begin
  170.   if (FFailRec.FailType <> ofNone)
  171.   and Assigned(FOnOpenFailure) then
  172.     FOnOpenFailure(Self, FFailRec.FailType);
  173.   FFailRec.FailType := ofNone;
  174.   inherited DoAfterOpen;
  175. end;
  176.  
  177. procedure TDBFTable.DoAfterPost;
  178. begin
  179.   if FAutoSaveChanges then
  180.     DBISaveChanges(Handle);
  181.   inherited DoAfterPost;
  182. end;
  183.  
  184. procedure TDBFTable.DoAfterDelete;
  185. begin
  186.   if FAutoSaveChanges then
  187.     DBISaveChanges(Handle);
  188.   inherited DoAfterDelete;
  189. end;
  190.  
  191. procedure TDBFTable.SetAtDBTMissing(Value: TDBFAtDBTMissing);
  192. begin
  193.   if (FFailRec.DBTAction <> Value) then
  194.     FFailRec.DBTAction := Value;
  195. end;
  196.  
  197. procedure TDBFTable.SetAtMDXMissing(Value: TDBFAtMDXMissing);
  198. begin
  199.   if (FFailRec.MDXAction <> Value) then
  200.     FFailRec.MDXAction := Value;
  201. end;
  202.  
  203. procedure TDBFTable.SetAutoSaveChanges(Value: boolean);
  204. begin
  205.   if (FAutoSaveChanges <> Value) then
  206.     FAutoSaveChanges := Value;
  207. end;
  208.  
  209. {-----------------}
  210.  
  211. procedure Register;
  212. begin
  213.   RegisterComponents('DBAddOns', [TDBFTable]);
  214. end;
  215.  
  216. end.
  217.